home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
PGM_TOOL
/
PREVIEW
/
CLP2DLFI
/
COMCODE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-11-10
|
32KB
|
1,196 lines
unit CommonCode;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, Mask, DBFserver,
wAboutBx;
const MAXPARS=20;
UPARROW=38; { in KeyDown events, GetUp(),GetDown(),GetEsc() }
DNARROW=40;
ESCKEY=27;
RETKEY=13;
RETCHAR=#13; { in KeyPress events, GetRet() }
NULLCHAR=#0;
DNCHAR=#40;
UPCHAR=#38;
ESCCHAR=#27;
MaxMiscWin=20;
MaxModify=20;
MaxWait=20;
type
WinRec=Record
wForm:Tform;
wClass:string[20];
wHandle:THandle;
top,left,width,height:integer;
end;
oTForm=Class(TForm)
public
procedure SelNext(GoForward,CheckTab:boolean);
end;
GenVars=class(TObject)
public
AtPDS:boolean;
CanBrowse:boolean;
CanBrowseModify:boolean;
CanSeePrice:boolean;
{ list of 'corefile' names they can modify during browse }
CanModifyList:array [1..MaxModify] of string[10];
CanModifyCnt:integer;
{ list of files they can't even view in browse }
CantViewList:array [1..MaxModify] of string[10];
TempFCnt,CantViewCnt:integer;
User:string[20];
Station:string[20];
EmpNum:string[20];
ExeSource:string[60];
CodeSource:string[2];
CompanyName:string[70];
RootDir,RootVol:string[20];
MultiLok:oDB; { alias name }
MiscWinList:array [1..MaxMiscWin] of WinRec;
MiscWinCnt,MiscWinMatch,MiscFndCnt:integer;
MiscWinFnd:array [1..MaxMiscWin] of integer;
DebugList:array [1..200] of string[15];
DebugCnt:integer;
WaitList:array [1..MaxWait] of TButton;
WaitText:array [1..MaxWait] of String30;
{ used to store BluePrint Images }
FullBP,TinyBP,PrintBP:TBitMap;
InBluePrint:boolean; { only allow one open at a time }
procedure SetAccess;
procedure AddModify(astr:string);
function ModifyOK(astr:string):boolean;
function CantView(astr:string):boolean;
procedure AddWin(aClass:string;aWindow:TForm);
function FindWin(aClass,KeyElement:string):integer;
procedure ReleaseWin(aWindow:TForm);
end;
procedure StartCommonCode;
procedure StopCommonCode;
function ComPath(dbfname:string):string;
function JcPath(dbfname:string):string;
function ArPath(dbfname:string):string;
function ApPath(dbfname:string):string;
function GlPath(dbfname:string):string;
function PrPath(dbfname:string):string;
function TempPath(fname:string):string;
function frmpath(dbfname:string):string;
function ArchPath(dbfname:string):string;
function TempArch(dbfname:string):string;
function Tmpfname(Ending:string):string;
function Tmpfdbf:string;
function NextTemp:string;
function NumsEqual(nn1,nn2:double):boolean;
function GetDept(depnum:string):string;
function CutJobNo(snum:string):string;
function nDep(dnum:string):string;
function LongTime:string;
function PreviousInstance:boolean;
procedure MakeInstance;
procedure ClearInstance;
procedure ClearFlagUse;
{ ltype: "J" - Job locked, "R"-routcard, "I"-in process inspect.
"F" - final inspect, "W" - window open }
procedure FlagOn( idcode,ltype:string); { call after locking record }
procedure FlagOff(idcode,ltype:string);
function FlagGet(idcode,ltype:string):string;
procedure AccessDenied(f1,f2:string); { OKbox calls FlagGet }
function GetProgIni(fromSection,fromKey:string):string;
procedure PutProgIni(toSection,toKey,newValue:string);
procedure Split(orgline,pchar:string;
var resarr:array of string135;var rescnt:integer);
function unSplit(var arr1:array of string135;delim:string;
acnt:integer):string;
procedure LongSplit(orgline:PChar;Delim:string;resstr:tstringlist);
procedure LongunSplit(SaveTo:Pchar;delim:string;resstr:tstringlist);
procedure uzTmpDBF(var pDBF:oDB;keyexp:string);
function StrTran(aStr,ChgPattern,ToPattern:string):String;
procedure AtSay(var tt:string;StartCol:integer;aStr:string);
procedure MouseWait;
procedure MouseGo;
function noExt(fname:string):string;
function iifi(abool:boolean;ret1,ret2:integer):integer;
function iifs(abool:boolean;ret1,ret2:string):string;
function iifd(abool:boolean;ret1,ret2:double):double;
procedure CenterForm(aform:Tform);
procedure CenterHoriz(aform:Tform);
procedure LoadFileList(DirPath,FileSkeleton:string;var files:TStringList);
procedure CopyFile(frm,too:string);
procedure ShowStatus; { must call before using SaveStatus or DebugShow }
procedure SaveStatus(SaveText:string);
procedure DebugShow(SaveText:string);
function Pin(str1,instr2:string):boolean; { pos()>0 }
function uPin(str1,instr2:string):boolean; { uppercase them first, pos()>0 }
function GetMove(aWord:Word;tf:TForm):integer;
function GetEsc(aWord:Word):boolean;
function GetUp(aWord:Word):boolean;
function GetDown(aWord:Word):boolean;
function GetRet(var aChar:char):boolean;
procedure WaitOn(tb:TButton);
procedure WaitOff(tb:TButton);
procedure DBFbrowse(OpenExisting:string);
var Gen:GenVars;
ParsCnt:integer;
Pars:array [1..MAXPARS] of string135;
implementation
uses WinBrows;
procedure AccessDenied(f1,f2:string);
begin
OKbox('Access Denied - In Use By '+FlagGet(f1,f2));
end;
procedure DBFbrowse(OpenExisting:string);
begin
if Gen.FindWin('Browse','')=0 then begin
if Gen.CanBrowse then begin
WinBrowse:=TWinBrowse.create(application);
if not empty(OpenExisting) then begin
WinBrowse.OpenNow(OpenExisting);
end;
end else begin
if Gen.CanModifyCnt=0 then begin
OKBox('Browse Not Available');
exit;
end else begin
WinBrowse:=TWinBrowse.create(application);
if not empty(OpenExisting) then WinBrowse.OpenNow(OpenExisting);
end;
end;
end else WinBrowse.Show;
end;
function GetRet(var aChar:char):boolean;
begin
if aChar=escchar then aChar:=nullchar;
if aChar=retchar then begin
aChar:=nullchar;
Result:=true;
end else Result:=false;
end;
procedure oTForm.SelNext(GoForward,CheckTab:boolean);
begin
SelectNext(ActiveControl,GoForward,CheckTab);
end;
function GetProgIni(fromSection,fromKey:string):string;
var pSection,pKey,pDefault,Retstr,Filename:pchar;
begin
pSection:=stralloc(40);
pKey:=stralloc(40);
pDefault:=stralloc(40);
Retstr:=stralloc(140);
Filename:=stralloc(60);
strpcopy(pSection,fromSection);
strpcopy(pKey,fromKey);
strpcopy(pDefault,'');
strpcopy(FileName,'precdie.ini');
GetPrivateProfileString(pSection,pKey,pDefault,
Retstr,140,FileName);
Result:=strpas(Retstr);
strdispose(pSection);
strdispose(pKey);
strdispose(pDefault);
strdispose(Retstr);
strdispose(FileName);
end;
procedure PutProgIni(toSection,toKey,newValue:string);
var pSection,pKey,Filename,nuValue:pchar;
begin
pSection:=stralloc(40);
pKey:=stralloc(40);
Filename:=stralloc(60);
nuValue:=stralloc(60);
strpcopy(pSection,toSection);
strpcopy(pKey,toKey);
strpcopy(nuValue,newValue);
strpcopy(FileName,'precdie.ini');
WritePrivateProfileString(pSection,pKey,nuValue,FileName);
strdispose(pSection);
strdispose(pKey);
strdispose(nuValue);
strdispose(FileName);
end;
function GetMove(aWord:Word;tf:TForm):integer;
begin
result:=0;
if (aWord=uparrow) then begin
oTForm(tf).SelNext(false,true);
result:=-1;
end;
if ((aWord=dnarrow) or (aWord=retkey)) then begin
oTForm(tf).SelNext(true,true);
result:=1;
end;
end;
function GetUp(aWord:Word):boolean;
begin;
result:=(aWord=uparrow);
end;
function GetEsc(aWord:Word):boolean;
begin
result:=(aWord=esckey);
end;
function Pin(str1,instr2:string):boolean; { pos()>0 }
begin
result:=(pos(str1,instr2)>0);
end;
function uPin(str1,instr2:string):boolean; { pos()>0 }
begin
result:=(pos(uppercase(str1),uppercase(instr2))>0);
end;
function GetDown(aWord:Word):boolean;
begin;
result:=((aWord=dnarrow) or (aWord=retkey));
end;
procedure DebugShow(SaveText:string);
var ii:integer;
begin
with setupbox do begin
listbox1.items.add(SaveText);
ii:=0;
if listbox1.items.count>13 then ii:=listbox1.items.count-13;
listbox1.topindex:=ii;
end;
end;
procedure SaveStatus(SaveText:string);
var ii,seln:Integer;
tt:string;
begin
if Gen.DebugCnt<200 then begin
pp(Gen.DebugCnt);
Gen.DebugList[Gen.DebugCnt]:=SaveText;
end;
for ii:=1 to MaxDBFs do begin
if Gen.DebugCnt<200 then begin
DoEvents2;
tt:=dbSelectArea(ii);
if not empty(tt) then begin
pp(Gen.DebugCnt);
Gen.DebugList[Gen.DebugCnt]:=tt;
end;
end;
end;
end;
procedure ShowStatus;
begin
if Gen.FindWin('System Status','')=0 then
setupbox:=tsetupbox.create(application);
setupbox.show;
end;
procedure LoadFileList(DirPath,FileSkeleton:string;var files:TStringList);
var srch:TsearchRec;
ii:integer;
begin
files.clear;
if copy(DirPath,length(DirPath),1)<>'\' then DirPath:=DirPath+'\';
ii:=findfirst(DirPath+FileSkeleton,faAnyFile,srch);
files.sorted:=true;
while ii=0 do begin
files.add(srch.name);
ii:=findnext(srch);
end;
end;
procedure AtSay(var tt:string;StartCol:integer;aStr:string);
var ii:integer;
begin
ii:=length(tt);
if ii<StartCol then tt:=tt+space(StartCol-ii);
ii:=length(tt);
if ii>StartCol then tt:=copy(tt,1,ii);
tt:=tt+astr;
end;
procedure CenterForm(aform:Tform);
var ii:integer;
{ only for non-MDI forms }
begin
aform.top:=(screen.height-aform.height) div 2;
ii:=(screen.width-aform.width-8) div 2;
if ii<0 then aform.left:=0 else aform.left:=ii;
end;
procedure CenterHoriz(aform:Tform);
var ii:integer;
begin
ii:=(screen.width-aform.width-8) div 2;
if ii<0 then aform.left:=0 else aform.left:=ii;
end;
procedure MouseWait;
begin
Screen.Cursor:=crHourGlass;
Application.ProcessMessages;
end;
procedure MouseGo;
begin
Screen.Cursor:=crDefault;
Application.ProcessMessages;
end;
function compath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'comdat\'+dbfname;
end;
function frmpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'forms\'+dbfname;
end;
function jcpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'jcdat\'+dbfname;
end;
function PreviousInstance:boolean;
var tt,tt2:string;
begin
tt2:=gen.user; { must keep track of active user when diff from actual }
Gen.User:=GetEnv('USER');
tt:=tmpfname(Gen.CodeSource)+'.txt';
Gen.User:=tt2;
Result:=FileExists(tt);
end;
procedure MakeInstance;
var tt,tt2:string;
prhandle:integer;
begin
tt2:=gen.user; { must keep track of active user when diff from actual }
Gen.User:=GetEnv('USER');
tt:=tmpfname(Gen.CodeSource)+'.txt';
Gen.User:=tt2;
if not FileExists(tt) then begin
prHandle:=FileCreate(tt);
FileClose(prHandle);
end;
end;
procedure ClearInstance;
var tt,tt2:string;
begin
tt2:=gen.user; { must keep track of active user when diff from actual }
Gen.User:=GetEnv('USER');
tt:=tmpfname(Gen.CodeSource)+'.txt';
Gen.User:=tt2;
if FileExists(tt) then DeleteFile(tt);
end;
function tmpfname(Ending:string):string;
var fname:string[20];
begin
fname:=trim(copy(Gen.User,1,3))+
trim(copy(Gen.Station,length(Gen.Station)-2,3))+trim(Ending);
Result:=fname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+fname;
end;
function tmpfdbf:string;
var fname:string[20];
begin
fname:=trim(copy(Gen.User,1,3))+
trim(copy(Gen.Station,length(Gen.Station)-2,3));
Result:=fname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+GetUniqueAlias(fname);
end;
function StrTran(aStr,ChgPattern,ToPattern:string):String;
var tparscnt:integer;
tpars:array [1..MAXPARS] of string135;
begin
split(aStr,ChgPattern,tpars,tparscnt);
Result:=unsplit(tpars,ToPattern,tparscnt);
end;
function NextTemp:string;
begin
pp(Gen.TempFCnt);
if Gen.Tempfcnt>40 then Gen.tempfcnt:=1;
Result:=tmpfname(inttostr(Gen.tempfcnt)+'.txt');
end;
function arpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'ardat\'+dbfname;
end;
function appath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'apdat\'+dbfname;
end;
function glpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'gldat\'+dbfname;
end;
function prpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+Gen.RootDir+'prdat\'+dbfname;
end;
function archpath(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+'\accting\archive\'+dbfname;
end;
function TempPath(fname:string):string;
begin
Result:=fname;
if length(Gen.RootDir)>0 then begin
Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+fname;
end;
end;
function temparch(dbfname:string):string;
begin
Result:=dbfname;
if length(Gen.RootDir)>0 then
Result:=Gen.RootVol+'\accting\temparch\'+dbfname;
end;
procedure GenVars.AddModify(astr:string);
var ii:integer;
begin
split(trim(astr),' ',pars,parscnt);
for ii:=1 to parscnt do begin
if CanModifyCnt<MaxModify then begin
pp(CanModifyCnt);
CanModifyList[CanModifyCnt]:=upper(pars[ii]);
end;
end;
end;
function GenVars.ModifyOK(astr:string):boolean;
var ii:integer;
begin
Result:=false;
astr:=upper(astr);
if CanModifyCnt>0 then begin
for ii:=1 to CanModifyCnt do begin
if astr=CanModifyList[ii] then begin
Result:=true;
break;
end;
end;
end;
end;
function GenVars.CantView(astr:string):boolean;
var ii:integer;
begin
Result:=false;
astr:=upper(astr);
if CantViewCnt>0 then begin
for ii:=1 to CantViewCnt do begin
if astr=CantViewList[ii] then begin
Result:=true;
break;
end;
end;
end;
end;
procedure GenVars.SetAccess;
begin
CanSeePrice:=False;
CanBrowse:=False;
if pin(user,'BRAD DIANNE TONY CONNIE MARY ')
then CanBrowse:=True;
CanBrowseModify:=False;
if pin(User,'BRAD DIANNE CONNIE MARY ') then CanBrowseModify:=True;
if pin(User,'JOHN CONNIE BRAD TONY BEN JEFF GEORGE DIANNE ') then
CanSeePrice:=True;
{ setup which files they can make changes to }
CantViewList[1]:='EMP'; { nobody can browse emp.dbf }
CantViewList[2]:='CHART'; { nobody can browse emp.dbf }
CantViewCnt:=2;
if pin(user,'BRAD MARY ') then CantViewCnt:=0;
CanModifyCnt:=0;
if pin(User,'SONIA ') then begin
AddModify('custfax tlabor time');
end;
if pin(User,'CARL ') then begin
AddModify('parts cust vendors routcard routspec inprocess ipidata');
end;
end;
function numsequal(nn1,nn2:double):boolean; { NUMSEQUAL }
var nst1,nst2:string[20];
{ compare numbers for exact equality }
begin
nst1:=Copy(transform(nn1,'9999999.99999'),1,12);
nst2:=Copy(transform(nn2,'9999999.99999'),1,12);
Result:=(nst1=nst2);
end;
function cutjobno(snum:string):string; { CUTJOBNO }
var i1,i2:integer;
tj:string[30];
begin
{ return Job No from Inv. No. or Shipper No. }
i2:=0;
for i1:=1 to length(snum) do begin { look for last hyphen in number }
if Copy(snum,i1,1)='-' then begin
i2:=i1;
End;
End;
if i2>1 then begin
tj:=Copy(snum,1,i2-1);
End Else
Begin
tj:=Copy(snum,1,8);
End;
if length(tj)<10 then begin
tj:=tj+space(11);
tj:=Copy(tj,1,10);
End;
Result:=tj;
end;
function ndep(dnum:string):string; { NDEP }
const maxdep=31;
var ddi,ddj:integer;
depno:array [1..maxdep] of string[4];
deptitle:array [1..maxdep] of string[30];
procedure setdep(inum:integer;depnum,title:string);
begin
depno[inum]:=depnum;
deptitle[inum]:=title;
end;
begin
setdep( 1,'100','Supervisor');
setdep( 2,'11 ','Design');
setdep( 3,'12 ','Quality Control');
setdep( 4,'14 ','Die');
setdep( 5,'15 ','Gage');
setdep( 6,'16 ','Stamping');
setdep( 7,'17 ','Jig Bore / Machining');
setdep( 8,'18 ','Jig Grinding');
setdep( 9,'19 ','Wire EDM');
setdep(10,'200','Equipment Maint.');
setdep(11,'21 ','Temporary Help');
setdep(12,'3 ','Clerical');
setdep(13,'300','Clean Up');
setdep(14,'400','General Shop');
setdep(15,'5 ','Purchasing');
setdep(16,'500','Driving');
setdep(17,'600','Medical Time Off');
setdep(18,'700','Training / Education');
setdep(19,'800','Over-Run Inventory');
setdep(20,'9 ','Machine Maint.');
if Gen.AtPDS then setdep(21,'900','Prec.Gage Eq. Maint.')
else setdep(22,'900','P.Die Equip. Maint.');
setdep(23,'901','Acct/Rpts/Txs/Stmts.');
setdep(24,'902','Precision Gage Work');
setdep(25,'903','Admin/Ins./Personnel');
setdep(26,'904','Clerical/Type/Filing');
setdep(27,'905','Computer Work');
setdep(28,'906','Job Quote/Update/BPS');
setdep(29,'907','Job Setup/PO''s/Info');
setdep(30,'908','Ship/Inv/Rec/Filing');
setdep(31,'909','Phone & Reception');
ddj:=0;
for ddi:=1 to maxdep do begin
if dnum=depno[ddi] then begin
ddj:=ddi;
break;
End;
End;
if ddj>0 then begin
Result:=deptitle[ddj];
end else Result:='* Dept. Unknown *';
end;
function longtime:string; { LONGTIME }
var thr:integer;
tmin,ttime:string[20];
tdate:TDateTime;
begin
tdate:=time;
ttime := FormatDateTime('hh:nn',tdate);
thr := strtoint(Copy(ttime,1,2));
tmin := Copy(ttime,4,2);
if thr >= 12 then begin
ttime := ' pm';
if thr>12 then begin
thr := thr-12;
End;
End Else
Begin
ttime := ' am';
End;
Result:=transform(thr,'99')+':'+tmin+ttime;
end;
procedure split(orgline,pchar:string;
var resarr:array of string135;var rescnt:integer);
var aline:string;
ii,jj,kk,acnt,plen:integer;
ats:array [1..80] of integer;
begin
for ii:=0 to high(resarr) do resarr[ii]:='';
rescnt:=0;
for ii:=1 to 80 do ats[ii]:=0;
aline:=trim(orgline);
jj:=length(aline);
plen:=length(pchar);
if jj>0 then begin
rescnt:=1;
ats[rescnt]:=0;
for ii:=1 to jj do begin
if Copy(aline,ii,plen)=pchar then begin
pp(rescnt);
ats[rescnt]:=ii;
End;
End;
ats[rescnt+1]:=jj;
if rescnt=1 then begin
resarr[0]:=aline;
End Else
Begin
for ii:=1 to rescnt do begin
if ii=1 then begin
kk:=ats[ii+1]-ats[ii]-1;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,1,kk);
End;
end else
if ii=rescnt then begin
kk:=ats[ii+1]-ats[ii]-plen+1;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
End;
end Else
begin
kk:=ats[ii+1]-ats[ii]-plen;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
End;
End;
End;
End;
End;
end;
function unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
{ array may be 1 based, but when passed in it becomes 0 based }
var ii,jj,pp:integer;
tt:string;
begin
tt:='';
if acnt=1 then begin
tt:=arr1[0];
End;
if acnt>1 then begin
for ii:=0 to acnt-2 do begin
tt:=tt+arr1[ii]+delim;
End;
tt:=tt+arr1[acnt-1];
End;
Result:=tt;
end;
procedure LongSplit(orgline:PChar;Delim:string;resstr:tstringlist);
var aline,atemp,tdel,curpos,delpos:pchar;
ii,jj,plen:integer;
begin
atemp:=stralloc(MaxMemoSize); { keep track of org pointer, aline is changed }
tdel:=stralloc(2);
strpcopy(tdel,delim);
strcopy(atemp,orgline);
TrimStr(atemp);
aline:=atemp;
resstr.clear;
jj:=strlen(aline);
plen:=strlen(tdel);
delpos:=strpos(aline,tdel);
while delpos<>nil do begin
delpos^:=#0;
resstr.add(strpas(aline));
inc(aline,length(resstr[resstr.count-1])+plen);
delpos:=strpos(aline,tdel);
end;
resstr.add(strpas(aline));
strdispose(atemp);
strdispose(tdel);
end;
procedure LongunSplit(SaveTo:Pchar;delim:string;resstr:tstringlist);
var ii:integer;
temp:pchar;
begin
temp:=stralloc(140);
strpcopy(SaveTo,'');
if resstr.count=1 then begin
strpcopy(SaveTo,resstr[0]);
End;
if resstr.count>1 then begin
for ii:=0 to resstr.count-2 do begin
strpcopy(temp,resstr[ii]);
strcat(SaveTo,temp);
strpcopy(temp,delim);
strcat(SaveTo,temp);
End;
strpcopy(temp,resstr[resstr.count-1]);
strcat(SaveTo,temp);
End;
strdispose(temp);
end;
procedure uztmpdbf(var pDBF:oDB;keyexp:string);
var dn,tt,tt2:string;
ii:integer;
fn,ft:array [1..10] of string;
fw,fd:array [1..10] of integer;
begin
dn:='';
for ii:=1 to 20 do begin
tt2:=tmpfdbf+inttostr(ii);
tt:=CoreFile(tt2);
if dbSelect(tt)=0 then begin
if FileExists(tt2+'.dbf') then DeleteFile(tt2+'.dbf');
if FileExists(tt2+'.cdx') then DeleteFile(tt2+'.cdx');
dn:=tt2;
break;
end;
end;
if empty(dn) then begin
OKBox('Unable To Open Temp DBF '+tt2);
end else begin
fn[1]:='emp_no'; ft[1]:='C'; fw[1]:=3; fd[1]:=0;
fn[2]:='part_no'; ft[2]:='C'; fw[2]:=20; fd[2]:=0;
fn[3]:='job_no'; ft[3]:='C'; fw[3]:=10; fd[3]:=0;
fn[4]:='po_no'; ft[4]:='C'; fw[4]:=15; fd[4]:=0;
fn[5]:='cust_no'; ft[5]:='C'; fw[5]:=6; fd[5]:=0;
fn[6]:='idx_key'; ft[6]:='C'; fw[6]:=30; fd[6]:=0;
fn[7]:='rec_no'; ft[7]:='N'; fw[7]:=8; fd[7]:=0;
fn[8]:='hours'; ft[8]:='N'; fw[8]:=9; fd[8]:=2;
fn[9]:='recs'; ft[9]:='C'; fw[9]:=120; fd[9]:=0;
fn[10]:='jobarr'; ft[10]:='N'; fw[10]:=7; fd[10]:=0;
CreateDBF(dn,10,fn,ft,fw,fd);
{ tag name and key expression }
dbUseExclusive(pDBF,dn);
pDBF.CreateIndex(pDBF.Alias,keyexp);
dbClose(pDBF);
dbUseExclusive(pDBF,dn);
end;
end;
function GetDept(depnum:string):string;
begin
Result:='';
if depnum='11 ' then Result:='Design';
if depnum='12 ' then Result:='Quality Control';
if depnum='14 ' then Result:='Die';
if depnum='15 ' then Result:='Gage';
if depnum='16 ' then Result:='Stamping';
if depnum='17 ' then Result:='Jig Bore/Machining';
if depnum='18 ' then Result:='Jig Grinding';
if depnum='19 ' then Result:='Wire EDM';
end;
function FlagGet(idcode,ltype:string):string;
var tv:string[30];
oarea:boolean;
begin
{ also see AccessDenied() }
oarea:=dbIsClosed(Gen.Multilok);
if oarea then dbUse(Gen.Multilok,compath('multilok'));
tv:=padr(trim(upper(idcode)),20);
ltype:=upper(ltype);
Result:='';
if Gen.Multilok.Seek(tv+ltype) then begin
Result:=trim(Gen.Multilok.s('lockedby'));
end;
if oarea then dbClose(gen.multilok);
end;
procedure ClearFlagUse;
var ii:integer;
oarea:boolean;
emptyst,tname:string[30];
begin
tname:=padr(Gen.User,10);
oarea:=dbIsClosed(gen.multilok);
if oarea then dbUse(Gen.Multilok,compath('multilok'));
with Gen.Multilok do begin
setorder(0);
gotop;
while not eof do begin
if pin(Gen.User,s('lockedby')) then begin
Lock;
ss('lock_id',' ');
ss('lock_type',' ');
ss('lockedby',' ');
ss('locksource',' '); { 2 letter code for program it came from }
dd('dated',0);
ss('attime',' ');
unLock;
end;
skip;
end;
setorder(1);
end;
if oarea then dbclose(gen.multilok);
end;
procedure FlagOn(idcode,ltype:string);
var oarea:boolean;
emptyst,tv,tname:string[30];
begin
{ ltype codes: "W"-Window open, new types will need change in aboutbox
"R"-Routcard
"J"-Job Setup Change
"I"-In-process inspect.
"F"-Final inspect.
"S"-Shipper
"Q"-Shipper Request }
tname:=padr(Gen.User,10);
oarea:=dbIsClosed(gen.multilok);
if oarea then dbUse(Gen.Multilok,compath('multilok'));
tv:=padr(trim(upper(idcode)),20);
ltype:=upper(ltype);
emptyst:=space(20);
with Gen.Multilok do begin
if Seek(tv+ltype) then begin
lock;
end else begin
if Seek(emptyst) then begin
if not aLock then Append;
End Else
Begin
Append;
End;
end;
ss('lock_id',tv);
ss('lock_type',ltype);
ss('lockedby',Gen.User);
dd('dated',xDate);
ss('attime',longtime);
ss('locksource',Gen.CodeSource);
unLock;
end;
if oarea then dbclose(gen.multilok);
end;
procedure FlagOff(idcode,ltype:string);
var oarea:boolean;
tv,tname:string[30];
begin
{ a false return would mean possible corruption }
{ a P/N or Job No, ltype="R"-routcard, "I"-in process inspect. }
oarea:=dbIsClosed(Gen.Multilok);
if oarea then dbUse(Gen.Multilok,compath('multilok'));
tname:=padr(Gen.User,10);
tv:=padr(trim(upper(idcode)),20);
ltype:=upper(ltype);
with Gen.Multilok do begin
if Seek(tv+ltype) then begin
Lock;
ss('lock_id',' ');
ss('lock_type',' ');
ss('lockedby',' ');
ss('locksource',' ');
dd('dated',0);
ss('attime',' ');
unLock;
end;
end;
if oarea then dbclose(gen.multilok);
end;
procedure CopyFile(frm,too:string);
var p1,p2,p3:pchar;
ret,outfile,infile:integer;
bsize:word;
begin
if FileExists(too) then DeleteFile(too);
p1:=stralloc(130);
p2:=stralloc(130);
p3:=stralloc(1024);
StrPCopy(p1,frm);
strpcopy(p2,too);
infile:=_lopen(p1,0);
outfile:=filecreate(too);
if (infile>0) and (outfile>0) then begin
bsize:=_lread(infile,p3,1024);
while bsize=1024 do begin
ret:=_lwrite(outfile,p3,bsize);
if ret<0 then begin
bsize:=0;
break;
end;
bsize:=_lread(infile,p3,1024);
end;
if bsize>0 then _lwrite(outfile,p3,bsize);
end;
if infile>0 then _lclose(infile)
else begin
OKbox('CopyFile() Error: '+inttostr(infile)+' Opening '+frm)
end;
if outfile>0 then _lclose(outfile)
else begin
OKbox('CopyFile() Error: '+inttostr(outfile)+' Creating '+too)
end;
strdispose(p1);
strdispose(p2);
strdispose(p3);
end;
function GenVars.FindWin(aClass,KeyElement:string):integer;
var ii:integer;
tt:string;
begin
MiscWinMatch:=0;
MiscFndCnt:=0;
if MiscWinCnt>0 then begin
aClass:=upper(trim(aClass));
KeyElement:=upper(trim(KeyElement));
for ii:=1 to MiscWinCnt do begin
if aClass=MiscWinList[ii].wClass then begin
pp(MiscFndCnt);
MiscWinFnd[MiscFndCnt]:=ii;
tt:=upper(MiscWinList[ii].wForm.Caption);
if (not empty(KeyElement)) then begin
{ find exact match }
if pin(KeyElement,tt) then begin
if MiscWinMatch=0 then MiscWinMatch:=ii;
end;
end else begin
{ find first occurance }
if MiscWinMatch=0 then MiscWinMatch:=ii;
end;
end;
end;
end;
Result:=MiscWinMatch;
end;
procedure GenVars.AddWin(aClass:string;aWindow:TForm);
begin
if MiscWinCnt<MaxMiscWin then begin
pp(MiscWinCnt);
with MiscWinlist[MiscWinCnt] do begin
wForm:=aWindow;
wClass:=upper(aClass);
wHandle:=aWindow.handle;
top:=aWindow.top;
left:=aWindow.left;
width:=aWindow.width;
height:=aWindow.height;
end;
FlagOn(trim(Gen.User)+':'+aclass,'W');
end;
end;
procedure GenVars.ReleaseWin(aWindow:TForm);
var ii,jj,kk:integer;
begin
jj:=0;
if MiscWinCnt>0 then begin
for ii:=1 to MiscWinCnt do begin
if MiscWinList[ii].wHandle=aWindow.handle then begin
jj:=ii;
FlagOff(trim(Gen.User)+':'+MiscWinList[jj].wclass,'W');
break;
end;
end;
end;
if jj>0 then begin
{ shuffle everything up one spot }
kk:=0;
for ii:=1 to MiscWinCnt do begin
if ii<>jj then begin
pp(kk);
MiscWinList[kk].wForm:=MiscWinList[ii].wForm;
MiscWinList[kk].wClass:=MiscWinList[ii].wClass;
MiscWinList[kk].wHandle:=MiscWinList[ii].wHandle;
MiscWinList[kk].top:=MiscWinList[ii].top;
MiscWinList[kk].left:=MiscWinList[ii].left;
MiscWinList[kk].width:=MiscWinList[ii].width;
MiscWinList[kk].height:=MiscWinList[ii].height;
end;
end;
MiscWinCnt:=kk;
end;
end;
procedure WaitOn(tb:TButton);
var ii:integer;
begin
for ii:=1 to MaxWait do begin
if gen.WaitList[ii]=nil then begin
gen.Waitlist[ii]:=tb;
gen.WaitText[ii]:=tb.caption;
tb.caption:='Wait';
tb.enabled:=false;
break;
end;
end;
end;
procedure WaitOff(tb:TButton);
var ii:integer;
begin
for ii:=1 to MaxWait do begin
if gen.WaitList[ii]=tb then begin
gen.WaitList[ii]:=nil;
tb.caption:=gen.WaitText[ii];
tb.enabled:=true;
break;
end;
end;
end;
function noext(fname:string):string; { NOEXT return file name minus extension }
var ii:integer;
begin
ii:=pos('.',fname);
if ii>1 then begin
Result:=Copy(fname,1,ii-1);
End Else
Begin
Result:=fname;
End;
end;
function iifi(abool:boolean;ret1,ret2:integer):integer;
{ iif() when params are integer's }
begin
if abool then result:=ret1 else result:=ret2;
end;
function iifs(abool:boolean;ret1,ret2:string):string;
{ iif() when params are string's }
begin
if abool then result:=ret1 else result:=ret2;
end;
function iifd(abool:boolean;ret1,ret2:double):double;
{ iif() when params are double's }
begin
if abool then result:=ret1 else result:=ret2;
end;
procedure StartCommonCode;
var ii:integer;
tt:string;
ddb:oDB;
begin
Gen:=GenVars.Create;
with Gen do begin
CodeSource:='JC';
MiscWinCnt:=0;
User:='';
TempFCnt:=0;
ExeSource:=paramstr(0);
User:=upper(getenv('user'))+' ';
RootVol:='\\prec_die\sys';
RootDir:='\accting\';
EmpNum:=upper(getenv('empnum'));
if empty(EmpNum) then EmpNum:='001';
Station:=upper(getenv('station'));
if pin('0012',Station) then begin
RootVol:='d:';
RootDir:='\accting\';
end;
if pin(gen.user,'TONY ') then RootVol:='f:';
if Gen.User='BRAD ' then begin
if not pin('0012',Station) then begin
if YesNoBox('Use Test Data ([No] Actual Data)') then begin
RootDir:='\accttest\';
end;
tt:=inputbox('Run As User','Enter User Name','');
if not empty(tt) then gen.user:=upper(tt)+' ';
end;
end;
if empty(user) then begin
user:='BRAD ';
RootVol:='';
RootDir:='';
end;
multilok:=nil;
ddb:=nil;
{ since this routine is only run once, don't need to use DataSet method }
dbUse(Multilok,compath('multilok')); { should always be open }
AtPDS:=true;
CompanyName:='';
if not empty(rootdir) then begin
dbUse(ddb,compath('company'));
AtPDS:=ddb.b('at_company');
dbClose(ddb);
dbUse(ddb,jcpath('control'));
CompanyName:=ddb.st('company');
dbClose(ddb);
end;
DebugCnt:=0;
SetAccess;
for ii:=1 to MaxWait do Waitlist[ii]:=nil;
FullBP:=TBitMap.create;
TinyBP:=TBitMap.create;
PrintBP:=TBitMap.create;
InBluePrint:=false;
end;
end;
procedure StopCommonCode;
begin
Gen.FullBP.free;
Gen.TinyBP.free;
Gen.PrintBP.free;
gen.free;
end;
end.